home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hardcore Visual Basic 5.0 (2nd Edition)
/
Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso
/
Code
/
draw.bas
< prev
next >
Wrap
BASIC Source File
|
1997-06-14
|
7KB
|
186 lines
Attribute VB_Name = "MDraw"
Option Explicit
Const PI = 3.1415
Sub BmpSpiral(picSrc As Picture, cvsDst As Object)
With cvsDst
' Calculate sizes
Dim dxSrc As Long, dySrc As Long, dxDst As Long, dyDst As Long
dxSrc = .ScaleX(picSrc.Width): dySrc = .ScaleY(picSrc.Height)
dxDst = .ScaleWidth: dyDst = .ScaleHeight
' Set defaults (play with these numbers for different effects)
Dim xInc As Long, yInc As Long, xSize As Long, ySize As Long
Dim x As Long, y As Long
xInc = CInt(dxSrc * 0.01): yInc = CInt(dySrc * 0.01)
xSize = CInt(dxSrc * 0.1): ySize = CInt(dySrc * 0.1)
Dim radCur As Single, degCur As Integer, angInc As Integer
degCur = 0: angInc = 55
' Start in center
x = (dxDst \ 2) - (dxSrc \ 2): y = (dyDst \ 2) - (dySrc \ 2)
' Spiral until off destination
Do
' Draw at current position
.PaintPicture picSrc, x, y, , , , , , , vbSrcAnd
' Calculate angle in radians
radCur = (degCur - 90) * (PI / 180)
' Calculate next x and y
x = x + (xSize * Cos(radCur))
y = y + (ySize * Sin(radCur))
' Widen spiral
xSize = xSize + xInc: ySize = ySize + yInc + 1
' Turn angle
degCur = (degCur + angInc) Mod 360
Loop While (x > 0) And (x + dxSrc < dxDst - dxSrc) And _
(y > 0) And (y + dySrc < dyDst)
End With
End Sub
Sub SpiralBmp(picSrc As Picture, cvsDst As Object, _
ByVal xOff As Long, ByVal yOff As Long)
With cvsDst
Dim xLeft As Long, xRight As Long, yTop As Long, yBottom As Long
Dim dxSrc As Long, dySrc As Long, xSrc As Long, ySrc As Long
Dim xDst As Long, yDst As Long, xInc As Long, yInc As Long
Dim x As Long, y As Long
' Initialize
dxSrc = .ScaleX(picSrc.Width): dySrc = .ScaleY(picSrc.Height)
xInc = dxSrc / 20: yInc = dySrc / 20
xLeft = 0: yTop = 0:
xRight = dxSrc - xInc: yBottom = dySrc - yInc
' Draw each side
Do While (xLeft <= xRight) And (yTop <= yBottom)
' Top
For x = xLeft To xRight Step xInc
.PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
x, y, xInc, yInc, vbSrcCopy
Next
x = x - xInc: yTop = yTop + yInc
' Right
For y = yTop To yBottom Step yInc
.PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
x, y, xInc, yInc, vbSrcCopy
Next
y = y - yInc: xRight = x - xInc
' Bottom
For x = xRight To xLeft Step -xInc
.PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
x, y, xInc, yInc, vbSrcCopy
Next
x = x + xInc: yBottom = y - yInc
' Left
For y = yBottom To yTop Step -yInc
.PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
x, y, xInc, yInc, vbSrcCopy
Next
y = y + yInc: xLeft = xLeft + xInc
Loop
End With
End Sub
Sub Star(ByVal x As Long, ByVal y As Long, ByVal dxyRadius As Long, _
clrBorder As Long, clrOut As Long, clrIn As Long, cvsDst As Object)
With cvsDst
' Start is 144 degrees (converted to radians)
Const radStar As Double = 144 * PI / 180
' Calculate each point
Dim ptPoly(1 To 5) As POINTL, i As Integer
For i = 1 To 5
ptPoly(i).x = x + (Cos(i * radStar) * dxyRadius)
ptPoly(i).y = y + (Sin(i * radStar) * dxyRadius)
Next
' Set colors and style for star
.ForeColor = clrBorder ' SetTextColor
.FillColor = clrOut ' CreateSolidBrush
.FillStyle = vbSolid ' More CreateSolidBrush
'Call VBPolygon(.hDC, ptPoly)
' Set color for center
.FillColor = clrIn ' CreateSolidBrush
Call MGdiTool.VBFloodFill(.hDC, x, y, .ForeColor)
End With
End Sub
Sub Fade(obj As Object, _
Optional fRed As Boolean = False, _
Optional fGreen As Boolean = False, _
Optional fBlue As Boolean = True, _
Optional fVert As Boolean = True, _
Optional fHoriz As Boolean = False, _
Optional fLightToDark As Boolean = True)
With obj
' Trap errors
On Error Resume Next
' Save properties
Dim fAutoRedraw As Boolean, ordDrawStyle As Integer
Dim ordDrawMode As Integer, iDrawWidth As Integer
Dim ordScaleMode As Integer, ordPaletteMode As Integer
Dim rScaleWidth As Single, rScaleHeight As Single
fAutoRedraw = .AutoRedraw: iDrawWidth = .DrawWidth
ordDrawStyle = .DrawStyle: ordDrawMode = .DrawMode
rScaleWidth = .ScaleWidth: rScaleHeight = .ScaleHeight
ordScaleMode = .ScaleMode
' Err set if object lacks one of previous properties
If Err Then Exit Sub
' Only forms have PaletteMode, but ignore errors
If .PaletteMode <> 1 Then ordPaletteMode = .PaletteMode
' If you get here, object is OK (Printer lacks AutoRedraw)
fAutoRedraw = .AutoRedraw
' Set properties required for fade
.AutoRedraw = True
.DrawWidth = 2 ' Required for dithering
.DrawStyle = vbInsideSolid: .DrawMode = vbCopyPen
.ScaleMode = vbPixels
.ScaleWidth = 256 * 2: .ScaleHeight = 256 * 2
'.PaletteMode = vbPaletteModeUseZOrder
.PaletteMode = vbPaletteModeHalftone
'.Palette = .Picture
'.PaletteMode = vbPaletteModeCustom
Dim clr As Long, i As Integer, x As Integer, y As Integer
Dim iRed As Integer, iGreen As Integer, iBlue As Integer
For i = 0 To 255
' Set line color
If fLightToDark Then
If fRed Then iRed = 255 - i
If fBlue Then iBlue = 255 - i
If fGreen Then iGreen = 255 - i
Else
If fRed Then iRed = i
If fBlue Then iBlue = i
If fGreen Then iGreen = i
End If
clr = RGB(iRed, iGreen, iBlue)
' Draw each line of fade
If fVert Then
obj.Line (0, y)-(.ScaleWidth, y + 2), clr, BF
y = y + 2
End If
If fHoriz Then
obj.Line (x, 0)-(x + 2, .ScaleHeight), clr, BF
x = x + 2
End If
Next
' Put things back the way you found them
.AutoRedraw = fAutoRedraw: .DrawWidth = iDrawWidth
.DrawStyle = ordDrawStyle: .DrawMode = ordDrawMode
.ScaleMode = ordScaleMode
.ScaleWidth = rScaleWidth: .ScaleHeight = rScaleHeight
.PaletteMode = ordPaletteMode
End With
End Sub
'